home *** CD-ROM | disk | FTP | other *** search
/ SPACE 2 / SPACE - Library 2 - Volume 1.iso / apps / 142 / applic / sorter2.mod < prev    next >
Text File  |  1987-06-15  |  8KB  |  314 lines
  1. MODULE Sorter; (* to put lists in alpha or numeric order *)
  2. FROM Strings IMPORT Compare, Assign, CompareResults;
  3. FROM GEMDOS IMPORT ConIn, ConOut, ConWS, Open, Close, Create,
  4.      Read, Write, SFirst, GetDTA;
  5. FROM SYSTEM IMPORT ADDRESS, ADR;
  6. FROM Storage IMPORT ALLOCATE, DEALLOCATE;
  7.  
  8. CONST Maxnum = 2400;
  9.  
  10. VAR strg: ARRAY[1..Maxnum] OF ARRAY[0..80] OF CHAR;
  11.     buffer, fname: ARRAY[0..80] OF CHAR;
  12.     substrg: ARRAY[1..Maxnum] OF ARRAY[0..20] OF CHAR;
  13.     cardstrg: ARRAY[0..6] OF CHAR;
  14.     count: LONGCARD;
  15.     i, j, k, max, start, length, flen: CARDINAL;
  16.     a, ch: CHAR;
  17.     handle: INTEGER;
  18.     continue: BOOLEAN;
  19.  
  20. PROCEDURE CR;
  21. BEGIN
  22.   ConOut(CHR(13));
  23.   ConOut(CHR(10));
  24. END CR;
  25.  
  26.  
  27. PROCEDURE Conrs(VAR strg: ARRAY OF CHAR); (* my own ConRS *)
  28. VAR i: CARDINAL;
  29.     ch: CHAR;
  30. BEGIN
  31.   i:= 0;
  32.   LOOP (* until CR *)
  33.     ConIn(ch);
  34.     CASE ORD(ch) OF
  35.       13: strg[i]:= CHR(0); EXIT |
  36.        8: IF i > 0 THEN DEC(i); strg[i]:= CHR(0);
  37.            ELSIF i = 0 THEN ConOut(' ');
  38.           END; (* if *)
  39.           ConOut(' ');
  40.           ConOut(CHR(8));  |
  41.      ELSE strg[i]:= ch; INC(i);
  42.     END; (* case *)
  43.   END; (* loop *)
  44. END Conrs;
  45.  
  46.  
  47. PROCEDURE Pwr(x, exp: CARDINAL): CARDINAL;
  48. VAR i, y: CARDINAL;
  49. BEGIN
  50.   y:= x;
  51. (*  ConCard(x); ConOut('^'); ConCard(exp); ConOut('='); *)
  52.   IF exp = 0 THEN y:= 1;
  53.   ELSIF exp > 1 THEN
  54.     FOR i:= 2 TO exp DO
  55.       y:= y*x;
  56.     END; (* for *)
  57.   END; (* if *) (* note: if exp=1 then y just stays as x *)
  58. (*  ConCard(y);
  59.   ConIn(a); *) 
  60.   RETURN y;
  61. END Pwr;
  62.  
  63.  
  64. PROCEDURE Cardtostrg(x: CARDINAL; VAR cardstrg: ARRAY OF CHAR);
  65. VAR i, place: CARDINAL;
  66.     big: BOOLEAN;
  67. BEGIN
  68.   i:= 0;
  69.   big:= FALSE;
  70.   FOR place:= 5 TO 1 BY -1 DO
  71.     IF (x >= Pwr(10, place)) OR big THEN
  72.       cardstrg[i]:= CHR(x DIV Pwr(10, place) + 48);
  73.       x:= x MOD Pwr(10, place);
  74.       big:= TRUE;
  75.       i:= i + 1;
  76.     END; (* if *)
  77.   END; (* for place=5 to 1 *)
  78.   cardstrg[i]:= CHR(x + 48);
  79.   cardstrg[i + 1]:= CHR(0);
  80. END Cardtostrg;
  81.  
  82.  
  83. PROCEDURE Card(a: CHAR): CARDINAL;
  84. BEGIN
  85.   RETURN ORD(a)-48;
  86. END Card;
  87. (* this is only good for a one-digit number *)
  88.  
  89.  
  90. PROCEDURE Strgtocard(cardstrg: ARRAY OF CHAR): CARDINAL;
  91. VAR i, x, y: CARDINAL;
  92. BEGIN
  93.   x:= 0;
  94.   y:= 0;
  95.   i:= 0;
  96.   WHILE cardstrg[i] <> CHR(0) DO
  97.     y:= Card(cardstrg[i]);
  98.     x:= x * 10 + y;
  99.     INC(i);
  100.   END; (* while *)
  101.   RETURN x;
  102. END Strgtocard;
  103.  
  104.  
  105. PROCEDURE Sort;
  106. VAR i, j: CARDINAL;
  107. BEGIN
  108.   CR;
  109.   ConWS('Sorting...'); CR;
  110.   i:= 1;
  111.   REPEAT
  112.     FOR j:= i + 1 TO max DO
  113. (*      ConWS(substrg[i]); *)
  114.       IF Compare(substrg[j], substrg[i]) = Less THEN (* switch them *)
  115.         Assign(buffer, strg[i]);
  116.         Assign(strg[i], strg[j]);
  117.         Assign(strg[j], buffer);
  118.         Assign(buffer, substrg[i]);
  119.         Assign(substrg[i], substrg[j]);
  120.         Assign(substrg[j], buffer);
  121. (*      ConWS(' < '); *)
  122.       END; (* if less *)
  123. (*      ConOut(' ');
  124.       ConWS(substrg[j]); CR; *)
  125.     END; (* for j *)
  126.     Cardtostrg(i, cardstrg);
  127.     ConWS(cardstrg);
  128.     ConWS('= ');
  129.     ConWS(substrg[i]);
  130.     CR;
  131.     INC(i);
  132.   UNTIL i = max+1;
  133.   ConWS('Done sorting.'); CR;
  134. END Sort;
  135.  
  136.  
  137. PROCEDURE Flength(fname: ARRAY OF CHAR): CARDINAL;
  138. VAR address: ADDRESS;
  139.     result: INTEGER;
  140.     longaddress: POINTER TO LONGCARD;
  141. BEGIN
  142.   NEW(longaddress);
  143.   SFirst(fname, 0, result);
  144.   GetDTA(address);
  145.   longaddress:= address + 26;
  146.   RETURN CARDINAL(longaddress^);
  147. (*ConWS('writelongcard: ');
  148.   WriteLongCard(length, 0);
  149.   clength:= CARDINAL(length);
  150.   ConWS('writecard: ');
  151.   WriteCard(clength, 0);
  152.   Cardtostrg(clength, cardstrg);
  153.   ConWS('cardstrg: ');
  154.   ConWS(cardstrg);
  155. *)
  156. END Flength;
  157.  
  158.  
  159. PROCEDURE Getfile;
  160. VAR i: CARDINAL;
  161. BEGIN
  162.   i:= 0;
  163.   REPEAT (* get file name *)
  164.     INC(i);
  165.     CR;
  166.     ConWS('File to sort: ');
  167.     Conrs(fname); CR;
  168.     ConWS('Getting file length...');
  169.     flen:= Flength(fname);
  170.     Cardtostrg(flen, cardstrg);
  171.     ConWS(cardstrg); CR;
  172.     ConWS('Opening: ');
  173.     ConWS(fname); CR;
  174.     Open(fname, 0, handle);
  175.     IF handle < 0 THEN
  176.       ConWS('ERROR: -');
  177.       Cardtostrg(VAL(CARDINAL, ABS(handle)), cardstrg);
  178.       ConWS(cardstrg);
  179.       IF handle = -33 THEN ConWS('  file not found.'); END;
  180.       CR;
  181.       IF i > 2 THEN ConWS("3 strikes, you're out."); HALT; END; (* if *)
  182.     END; (* if error *)
  183.   UNTIL handle > 0;
  184. END Getfile;
  185.  
  186.  
  187. PROCEDURE Intro(VAR continue: BOOLEAN);
  188. VAR a: CHAR;
  189. BEGIN
  190.   CR;
  191.   ConWS('         SORTER version 1.0'); CR; CR;
  192.   ConWS(' Written by Craig Harvey with TDI Modula-2.'); CR;
  193.   ConWS('   The CLEAR THINKING BBS 313-761-2444'); CR;
  194.   ConWS(' Ann Arbor, Michigan  3/1200 baud  24 hrs'); CR; CR;
  195.   ConWS('          Sorts any text file on a column range of your choice');
  196.   CR;
  197.   ConWS('            as long as each line ends with a Carriage Return.');
  198.   CR;
  199.   ConWS(' (e.g. a BBS list with the phone numbers in the same columns of each  line)'); CR; CR;
  200.   ConWS(' ** Maximum file length = 64K, max line length = 80 **'); CR;
  201.   ConWS(' ** max lines = 2000    max sort string length = 20 **'); CR; CR;
  202.   ConWS(' Hit [Esc]ape or [Q]uit to quit or any other key to continue.'); CR;
  203.   ConIn(a);
  204.   IF (a = CHR(27)) OR (CAP(a) = 'Q') THEN continue:= FALSE;
  205.    ELSE continue:= TRUE;
  206.   END; (* if *)
  207. END Intro;
  208.  
  209.  
  210. BEGIN
  211.   i:= 1;
  212.   count:= 1;
  213.   Intro(continue);
  214. IF continue THEN (* do the deal *)
  215.   
  216.   Getfile;
  217.   ConWS(' Sort string starts at what column [1]: ');
  218.   Conrs(cardstrg); CR; CR;
  219. (*ConWS('startstrg = ');
  220.   ConWS(cardstrg); ConOut('!'); CR;
  221. *)
  222.   IF cardstrg[0] = CHR(0) THEN start:= 0;
  223.    ELSE start:= Strgtocard(cardstrg) - 1;
  224.   END; (* if *)
  225. (*  ConWS('starting column = ');
  226.   Cardtostrg(start + 1, cardstrg);
  227.   ConWS(cardstrg);
  228.   CR;
  229. *)
  230.   ConWS(' Length of sort string [12]: ');
  231.   Conrs(cardstrg);
  232.   IF cardstrg[0] = CHR(0) THEN length:= 12;
  233.    ELSE length:= Strgtocard(cardstrg);
  234.   END; (* if *)
  235.   CR; CR;
  236.   ConWS(' Reading file...'); CR;
  237.   k:= 0; (* counter of bytes of file *)
  238.   LOOP (* read file into array, until eof *)
  239.     j:= 0;
  240.     ConOut('.');
  241.     REPEAT (* until eol *)
  242.       INC(k);
  243.       Read(handle, count, ADR(ch));
  244.       strg[i, j]:= ch;
  245.       INC(j);
  246.     UNTIL (ch = CHR(10)) OR (k >= flen);
  247.     IF ch = CHR(10) THEN strg[i, j]:= CHR(0); INC(i); END; (* if *)
  248.     IF k >= flen THEN EXIT; END; (* if *)
  249. (*    Cardtostrg(i-1, cardstrg);
  250.     ConWS('strg[');
  251.     ConWS(cardstrg);
  252.     ConOut(']');
  253.     ConWS('= ');
  254.     ConWS(strg[i-1]);
  255.     Cardtostrg(k, cardstrg);
  256.     ConWS(cardstrg);
  257.     CR; *)
  258.   END; (* loop *)
  259.   CR;
  260.   IF Close(handle) THEN ConWS('done reading, hit a key.'); CR;
  261.    ELSIF NOT Close(handle) THEN ConWS('** Not closed for some reason **');
  262.   END; (* if *)
  263.   ConIn(a);
  264.   max:= i - 1;
  265.   Cardtostrg(max, cardstrg);
  266.   ConWS(cardstrg);
  267.   ConWS(' lines to be sorted. Hit a key.');
  268.   ConIn(a); CR;
  269.   ConWS('Getting sort strings... '); CR;
  270.   FOR i:= 1 TO max DO
  271.     FOR j:= 0 TO length - 1 DO
  272. (*    Cardtostrg(j, cardstrg);
  273.       ConWS('j= ');
  274.       ConWS(cardstrg); CR; *)
  275.       substrg[i, j]:= strg[i, start + j];
  276.     END; (* for j *)
  277.     substrg[i, length]:= CHR(0);
  278. (*    Cardtostrg(i, cardstrg);
  279.     ConWS(cardstrg);
  280.     ConOut(' ');
  281.     ConWS(substrg[i]);
  282.     ConOut('!');
  283.     CR;
  284. *)
  285.   END; (* for i *)
  286.  
  287.   Sort;
  288.  
  289.   Create('SORTED.NEW', 0, handle);
  290.   i:= 0;
  291.   j:= 0;
  292.   ConWS('Writing to new file: SORTED.NEW  please wait...'); CR;
  293.   REPEAT (* until done *)
  294.     INC(i);
  295.     j:= 0;
  296. (*  Cardtostrg(i, cardstrg);
  297.     ConWS(cardstrg); CR; 
  298.     ConWS(strg[i]);
  299. *)
  300.     LOOP
  301.       ch:= strg[i, j];
  302.       IF ch = CHR(0) THEN EXIT;
  303.        ELSE Write(handle, count, ADR(ch));
  304.             INC(j);
  305.       END; (* if *)
  306.     END; (* loop *)
  307.   UNTIL i >= max;
  308.   IF Close(handle) THEN ConWS('New file written. Hit a key.');
  309.   END; (* if *)
  310.   ConIn(a);
  311.   
  312. END; (* if continue *)
  313. END Sorter.
  314.